perm filename BUNDLE[CRE,BGB] blob
sn#020870 filedate 1973-01-24 generic text, type T, neo UTF8
00100 SUBR(BUNDLE)LEVEL-------------------------------------------------
00200 BEGIN BUNDLE; BGB - 28 DECEMBER 1972.
00300 ;MAKE ARC RADIAL POINTERS FROM THIS LEVEL TO BELOW.
00400
00500 ;A SINGLE VIC RADIAL INDICATES PARALLEL COINCIDANT VIC.
00600 ;AN ARC INDICATES A SET OF NEARLY COLINEAR VIC.
00700 SKIPN FLGKRK↔POP1J
00800 LAC 1,ARG1 ;LEVEL
00900 SON 1,1 ;POLYGON.
01000 DAC 1,PG0 ;FIRST POLYGON.
01100
01200 ;POLYGON PROCESSING LOOP.
01300 L1: DAC 1,IPG↔EXO 0,1↔JUMPE L3
01400 ARC 2,1↔DAC 2,ARCI↔ARC 2,2↔DAC 2,IV0↔DAC 2,IV1
01500 JUMPE 2,[FATAL(BUNDLE)]
01600 EXO 1,1↔ ARC 2,1↔DAC 2,ARCO↔ARC 2,2↔DAC 2,OV0↔DAC 2,OV1
01700 JUMPE 2,[FATAL(BUNDLE)]
01800
01900 ;VIC PROCCESSING LOOP.
02000 L2: CALL(NEXRAD,OV1,IV1)↔GO L3↔DAC FLAG ;LAST TIME FLAG.
02100 DAC 2,OV1↔DAC 3,IV1
02200 DAC 4,ARCO
02300 DAC 5,ARCI
02400 TEST 4,ARCBIT↔GO[FATAL({ARCO AIN'T ARC})]
02500 TEST 5,ARCBIT↔GO[FATAL({ARCI AIN'T ARC})]
02600 CALL(TRYEASY,ARCO,ARCI)
02700 SKIPN FLAG↔GO L2
02800
02900 ;ADVANCE TO NEXT POLYGON OF THIS LEVEL.
03000 L3: LAC 1,IPG↔CCW 1,1
03100 CAME 1,PG0↔GO L1
03200 POP1J↔LIT
03300
03400 DECLARE{IV1,OV1,FLAG,IPG,PG,PG0,ARCO,ARCI}
03500 BEND;1/5/73-------------------------------------------------------
03600
03700 DECLARE{IV0,OV0}
03800 BRAD1: 3.0
03900 BRAD2: 1.8
00100 SUBR(NEXRAD)OV,IV-------------------------------------------------
00200 BEGIN NEXRAD; BGB - 28 DECEMBER 1972.
00300 ;GET NEXT NEW VERTEX WITH A RADIAL POINTER.
00400
00500 ACCUMULATORS{OV,IV,ARCO,ARCI,PG,R,S}
00600 ;RETURN VALUES PER ACCUMULATORS:
00700 ; AC-2 OV OUTER VERTEX.
00800 ; AC-3 IV INNER VERTEX.
00900 ; AC-4 ARCO ARC OUTER.
01000 ; AC-5 ARCI ARC INNER.
01100
01200 SETZ
01300 LAC OV,ARG2
01400 LAC IV,ARG1
01500 PGON PG,IV
01600 L0: SKIPE↔POP2J↔SETZ R,
01700
01800 ;ADVANCE IV CCW UNTIL EXO RADIAL.
01900 L1: EXO R,IV↔JUMPN R,L2
02000 CCW IV,IV↔CAME IV,IV0↔GO L1
02100
02200 ;ADVANCE OV CCW UNTIL ENDO RADIAL.
02300 L2: ENDO S,OV↔JUMPN S,[
02400 PGON 1,S↔CAME S,PG↔GO .+1
02500 LAC IV,S↔SETZ R,↔GO L4]
02600 CAMN OV,R↔GO L4
02700 CCW OV,OV↔CAME OV,OV0↔GO L2↔POP2J
02800
02900 ;BACKUP OV & IV CW TO A VERTEX WITH AN ARC.
03000 L4: LAC 1,OV↔ARC ARCO,1↔JUMPN ARCO,.+3↔CW 1,1↔GO .-3
03100 LAC 1,IV↔ARC ARCI,1↔JUMPN ARCI,.+3↔CW 1,1↔GO .-3
03200
03300 ;ADVANCE ONE OR THE OTHER VIC POINTER FOR NEXT TIME.
03400 L3: SKIPE R
03500 GO[CCW IV,IV↔CAMN IV,IV0↔SETO↔GO .+4]
03600 CCW OV,OV↔CAMN OV,OV0↔SETO
03700
03800 ;IF ARCS ALREADY CONNECTED THEN PRESS ONWARD.
03900 ENDO 1,ARCO↔CAMN 1,ARCI↔GO L0
04000 EXO 1,ARCI↔CAMN 1,ARCO↔GO L0
04100 AOS(P)↔POP2J↔LIT↔VAR
04200
04300 BEND;1/6/73-------------------------------------------------------
00100 SUBR(TRYEASY)ARCO,ARCI-------------------------------------------
00200 BEGIN TRYEASY;TEST FOR EASY CASES AND CALL TRYHARD FOR HARD CASES.
00300 ;BGB - 28 DEC 1972 - ARC ARGUMENTS ALLEGED COINCIDENT & PARALLEL.
00400 ACCUMULATORS{ARCO,ARCI,ARCO2,ARCI2,R,C}
00500
00600 ;"UPPER" VERTICES OF THE PARALLELS.
00700 SETZM FLAG#
00800 LAC ARCO,ARG2
00900 LAC ARCI,ARG1
01000
01100 ;TEST FOR EASY CASE.
01200 CALL(DISTANCE,ARCO,ARCI)
01300 CAMG 1,BRAD1↔GO L2
01400
01500 ;TEST FOR "HIGHER" VERTEX - THE "LOWER" ONE IS BETWEEN ENDS.
01600 CCW ARCO2,ARCO
01700 ROW R,ARCI↔COL C,ARCI
01800 ROW 0,ARCO↔ROW 1,ARCO2↔CAMLE 0,1↔EXCH 0,1
01900 CAMGE R,0↔GO L1↔CAMLE R,1↔GO L1
02000 COL 0,ARCO↔COL 1,ARCO2↔CAMLE 0,1↔EXCH 0,1
02100 CAMGE C,0↔GO L1↔CAMLE C,1↔GO L1
02200
00100 ;ARC OUTER IS "HIGHER".
00200 L0: CCW ARCO,ARCO
00300 CALL(DISTANCE,ARCO,ARCI)
00400 CAMG 1,BRAD1↔GO L2↔CW ARCO,ARCO
00500 SETQ(ARCO,{TRYHARD,ARCI,ARCO})
00600 LAC ARCI,1(P)
00700 JUMPE ARCO,POP2J.↔GO L2
00800
00900 ;ARC INNER IS "HIGHER".
01000 L1: CCW ARCI,ARCI
01100 CALL(DISTANCE,ARCO,ARCI)
01200 CAMG 1,BRAD1↔GO L2↔CW ARCI,ARCI
01300 SETQ(ARCI,{TRYHARD,ARCO,ARCI})
01400 LAC ARCO,1(P)
01500 JUMPE ARCI,POP2J.↔GO L2
01600
01700 ;MAKE ARC RADIAL LINKS BETWEEN INNER AND OUTER ARCS.
01800 L2: TEST ARCO,ARCBIT↔GO[FATAL({ARCO ¬ARC})]
01900 TEST ARCI,ARCBIT↔GO[FATAL({ARCI ¬ARC})]
02000 EXO. ARCO,ARCI
02100 ENDO. ARCI,ARCO
02200 SKIPE FLAG↔POP2J ;EXIT SECOND TIME AROUND.
02300
02400 ;TEST EASY ON THE LOWER VERTICES OF THE PARALLELS.
02500 SETOM FLAG
02600 CCW ARCO2,ARCO
02700 CCW ARCI2,ARCI
02800 CALL(DISTANCE,ARCO2,ARCI2)
02900 CAMLE 1,BRAD1↔GO L3
03000 LAC ARCO,ARCO2↔LAC ARCI,ARCI2↔GO L2
03100
03200 ;TEST FOR "HIGHER" VERTEX - THE "LOWER" ONE IS BETWEEN ENDS.
03300 L3: ROW R,ARCI2↔COL C,ARCI2
03400 ROW 0,ARCO↔ROW 1,ARCO2↔CAMLE 0,1↔EXCH 0,1
03500 CAMGE R,0↔GO L1↔CAMLE R,1↔GO[LAC ARCO,ARCO2↔GO L1]
03600 COL 0,ARCO↔COL 1,ARCO2↔CAMLE 0,1↔EXCH 0,1
03700 CAMGE C,0↔GO L1↔CAMLE C,1↔GO[LAC ARCO,ARCO2↔GO L1]
03800 LAC ARCI,ARCI2↔GO L0
03900 LIT
04000 BEND;1/5/73-------------------------------------------------------
00100 SUBR(DISTANCE)V1,V2-----------------------------------------------
00200 BEGIN DISTANCE
00300 DAC 2,TMP2↔DAC 3,TMP3
00400 LAC 3,ARG2↔ROW 0,3↔COL 1,3
00500 LAC 3,ARG1
00600 ROW 2,3↔SUB 0,2↔IMUL 0,0
00700 COL 2,3↔SUB 1,2↔IMUL 1,1
00800 ADD 0,1↔FSC 217↔CALL(SQRT,0)
00900 LAC 2,TMP2↔LAC 3,TMP3↔POP2J
01000 DECLARE{TMP2,TMP3}
01100 BEND;12/30/72-----------------------------------------------------
00100 SUBR(TRYHARD)V0,V1-------------------------------------------------
00200 BEGIN TRYHARD; TRY TO TIE V0 TO V1 BY SPLITTING THE ARC OF V1.
00300 ;BGB - 28 DECEMBER 1972.
00400 ACCUMULATORS{V0,V1,V2,V3,A,B,C,D,Q,X,Y}
00500
00600 ;PICKUP VERTICES.
00700 LAC V0,ARG2
00800 LAC V1,ARG1
00900 CCW V2,V1
01000
01100 ;PICKUP AND FLOAT LOCUS OF V0.
01200 COL X,V0↔FLO X,
01300 ROW Y,V0↔FLO Y,
01400
01500 ;COMPUTE NORMALIZED EDGE COEFFICIENTS OF EDGE V1-V2.
01600
01700 ROW A,V1↔FLO A, ; A ← Y1.
01800 COL B,V2↔FLO B, ; B ← X2.
01900 COL C,V1↔FLO C, ; C ← X1.
02000 ROW D,V2↔FLO D, ; D ← Y2.
02100
02200 LAC 1,B↔FMPR 1,A ; 1 ← X2*Y1.
02300 FSBR A,D↔FSBR B,C ; A ← Y1-Y2. B ← X2-X1.
02400 FMPR C,D↔FSBR C,1 ; C ← X1*Y2 - X2*Y1.
02500
02600 LAC 0,A↔FMPR 0,0
02700 LAC 1,B↔FMPR 1,1↔
02800 FADR 1,0↔CALL SQRT,1 ; Q ← SQRT(A*A + B*B).
02900
03000 FDVR A,1 ;DIVIDE BY Q.
03100 FDVR B,1
03200 FDVR C,1
03300
03400 ;COMPUTE DISTANCE FROM V0 TO THE EDGE.
03500 ; Q ← A*X0 + B*Y0 + C.
03600
03700 LAC Q,A↔FMP Q,X
03800 LAC 1,B↔FMP 1,Y
03900 FAD Q,1↔FAD Q,C
04000 MOVMS Q
04100
04200 ;IF DISTANCE GREATER THAN BUNDLE-RADIUS-2 THEN EXIT.
04300
04400 CAMLE Q,BRAD2↔GO LOSE
00100 ;COMPUTE LOCUS OF FOOT OF PERPENDICULAR DROPPED FROM V0.
00200
00300 ;Q ← 1/(A*A + B*B).
00400 ;D ← (B*X0 - A*Y0).
00500 ;X ← (B*D - A*C)*Q.
00600 ;Y ←-(A*D + B*C)*Q.
00700
00800 LAC 0,A↔FMP 0,0↔LAC 1,B↔FMP 1,1↔FAD 1,0↔SLACI Q,(1.0)↔FDVR Q,1
00900 FMP X,B↔FMP Y,A↔FSB X,Y↔LACN Y,X↔FMP X,B↔FMP Y,A
01000 LAC A↔FMP C↔FSBR X,↔FMPR X,Q↔FIX X,225000
01100 LAC B↔FMP C↔FSBR Y,↔FMPR Y,Q↔FIX Y,225000
01200
01300 ;MAKE CERTAIN THAT LOCUS OF V3 IS BETWEEN V1 AND V2.
01400
01500 ROW 0,V1↔ROW 1,V2
01600 CAMLE 0,1↔EXCH 0,1
01700 CAMGE Y,0↔GO LOSE
01800 CAMLE Y,1↔GO LOSE
01900
02000 COL 0,V1↔COL 1,V2
02100 CAMLE 0,1↔EXCH 0,1
02200 CAMGE X,0↔GO LOSE
02300 CAMLE X,1↔GO[
02400 LOSE: SETZ 1,↔POP2J]
02500
02600 ;SPLIT V1 AND TIE V3 TO V0.
02700
02800 SETQ(V3,{MAKE,[VBIT+ARCBIT+VREL]})
02900 PGON 0,V1↔PGON. 0,V3
02950 CNTRST 0,V1↔CNTRS. 0,V3
03000 CCW. V2,V3↔CW. V3,V2
03100 CCW. V3,V1↔CW. V1,V3
03200 ROW. Y,V3↔COL. X,V3
03300
03400 ;TRY TO FIND AN ARCLESS VERTEX NEAR V3.
03500
03600 ARC 1,V1↔JUMPE 1,LEXIT
03700 ARC 2,V2↔JUMPE 1,LEXIT
03800 CCW 1,1↔CAME 1,2↔GO[
03900 ROW 0,1↔SUB 0,Y↔MOVMS↔CAILE 200↔GO .-2
04000 COL 0,1↔SUB 0,X↔MOVMS↔CAILE 200↔GO .-2
04100 ARC. 1,V3↔ARC. V3,1↔GO .+1]
04200
04300 LEXIT: LAC 1,V3↔POP2J
04400 LIT
04500 BEND;12/30/72-----------------------------------------------------
00100 SUBR(MKWED1)IMAGE-------------------------------------------------
00200 BEGIN MKWED1;MAKE WINGED EDGES PHASE-1. ;HANG EDGE ON EVER VERTEX.
00300 ;BGB - 2 JANUARY 1973.
00400
00500 ACCUMULATORS{A,IM,LV,PG,F,E,V1,V2}
00600 EXTERN MKF,MKE
00700 SKIPN FLGKRK↔POP1J
00800
00900 ;GET ONE OF EVERYTHING.
01000 LAC IM,ARG1 ;IMAGE.
01100 SON LV,IM↔DAC LV,LV0# ;LEVEL.
01200 L1: SON PG,LV↔DAC PG,PG0# ;POLYGON.
01250 SKIPN PG↔POP1J
01300 L2: ARC V1,PG↔DAC V1,V0# ;VERTEX.
01400 JUMPE V1,L4
01500 SETQ F,{MKF,IM} ;FACE.
01600 L3: SETQ E,{MKE,IM} ;EDGE.
01700
01800 ;PASTE IN ONE FACE AND TWO VERTICES.
01900 PFACE. F,E
02000 PED. E,V1
02100 CCW V2,V1
02200 PVT. V1,E
02300 NVT. V2,E
02400
02500 ;MAKE WINGS ON PVT.
02600 CW V1,V1↔PED A,V1
02700 JUMPE A,.+5
02800 NCCW. A,E↔PCW. A,E
02900 NCW. E,A↔PCCW. E,A
03000
03100 ;CLOSE POLYGON LOOP.
03200 LAC V1,V2
03300 CAME V2,V0↔GO L3
03400 CW V1,V2
03500 PED A,V1↔PED E,V2↔PED. E,F
03600 NCCW. A,E↔PCW. A,E
03700 NCW. E,A↔PCCW. E,A
03800
03900 ;NEXT POLYGON OF A LEVEL & NEXT LEVEL OF AN IMAGE.
04000 L4: CCW PG,PG↔CAME PG,PG0↔GO L2
04100 CCW LV,LV↔CAME LV,LV0↔GO L1
04200 POP1J
04300
04400 BEND;1/4/73-------------------------------------------------------
00100 SUBR(MKWED2)IMAGE-------------------------------------------------
00200 BEGIN MKWED2;MAKE WINGED EDGES PHASE-2.
00300 ;PLACE A TEMPORARY EDGE ON EVER RADIAL, THEN KILL THEM.
00400 ;BGB - 4 JANUARY 1973.
00500
00600 EXTERN MKFE,GLUEVV,KLVE,KLFE
00700 ACCUMULATORS{F1,F2,E,V1,V2}
00800 SKIPN FLGKRK↔POP1J
00900
01000 ;LOOP THRU THE POLYGONS OF THE IMAGE FROM INNERMOST TO OUTER ONES.
01100
01200 LAC 1,ARG1↔SON 1,1 ;IMAGE.
01300 DAC 1,LV0#↔CCW 1,1 ;LEVEL.
01400 L1: DAC 1,LV#↔SON 1,1↔DAC 1,PG0# ;POLYGON.
01450 SKIPN PG0↔GO L6-3
01500 L2: DAC 1,PG#↔ARC 1,1↔DAC 1,V0# ;VERTEX.
01600
01700 L3: DAC 1,V#↔DAC 1,V1
01800 EXO V2,1↔JUMPE V2,L5 ;CHECK FOR RADIALS.
01900 ENDO 0,V2↔CAME 0,V1↔GO L5 ;RECIPROCITY REQUIRED.
02000 PED E,V2↔PFACE F2,E ;EXO POLYGONS FACE.
02100 PED E,V1↔NFACE F1,E ;ENDO POLYGONS FACE.
02200
02300 ;CREATE WINGED EDGE AT RADIAL.
02400
02500 JUMPE F1,[
02600 SETQ E,{GLUEVV,F2,V2,F1,V1}↔GO L4]
02700 CAME F1,F2↔GO[FATAL({MKWED2, F1 ≠ F2.})]
02800 SETQ E,{MKFE,V1,F1,V2}
02900 L4: MARK E,TMPBIT
03000
03100
03200 ;NEXT POLYGON OF A LEVEL & NEXT LEVEL OF AN IMAGE.
03300
03400 L5: LAC 1,V ↔CCW 1,1↔CAME 1,V0↔GO L3
03500 LAC 1,PG↔CCW 1,1↔CAME 1,PG0↔GO L2
03600 LAC 1,LV↔CCW 1,1↔CAME 1,LV0↔GO L1
03700
03800 ;KILL ALL THE EDGES THAT WERE JUST CREATED.
03900
04000 LAC 1,ARG1↔NED 1,1↔DAC 1,EDGE
04100 L6: LAC 1,EDGE#
04200 NED 2,1↔DAC 2,EDGE ;SAVE NEXT ONE.
04300 TEST 1,TMPBIT↔GO L7
04400 TEST 1,EBIT↔GO L7
04500 CALL(KLVE,1) ;KILL THIS ONE.
04600 GO L6
04700
04800 L7: GO KL2SID ;OLDE LISP LIKE EXIT.
04900
05000 BEND;1/4/73-------------------------------------------------------
00100 SUBR(KL2SID)IMAGE-------------------------------------------------
00200 BEGIN KL2SID; BGB - 5 JAN 1973.
00300
00400 ;KILL ALL THE 2 SIDED FACES OF AN IMAGE.
00500 ACCUMULATORS{E,F1,F2}
00600 LAC 1,ARG1↔PFACE F1,1↔GO L2+1
00700 L1: PFACE F2,F1
00800 DAC F2,FACE#
00900
01000 ;TEST PED FOR IDENTICAL WINGS IN THE GIVEN FACE.
01100 PED E,F1
01200 PFACE 0,E
01300 CAME 0,F1↔GO[
01400 NCW 0,E↔NCCW 1,E↔GO .+3]
01500 PCW 0,E↔PCCW 1,E
01600 CAME 0,1↔GO L2
01700 CALL(KLFE,E)
01800
01900 ;ADVANCE TO NEXT FACE - EXIT ON NON-FACE.
02000 L2: LAC F1,FACE
02100 TEST F1,FBIT
02200 POP1J
02300 GO L1
02400 LIT↔VAR
02500 BEND;1/5/73-------------------------------------------------------